home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
forth
/
amiga
/
amigaker.arc
/
04.vars
< prev
next >
Wrap
Text File
|
1987-12-30
|
19KB
|
555 lines
;
; 04.vars&strings
;
; System variables
;
; String handling
;
* sp0 Initial stack pointer, a variable.
; Set by initializing code, used to reset system
dc.w -1
dc.l link3
link3 set *-4
dc.b $83,'sp',$80!'0'
cnop 0,2
_sp0 dc.l docreate
init_sp dc.l 0
* rp0 Initial return pointer, a variable.
; Set by initializing code, used to reset the system.
dc.w -1
dc.l link2
link2 set *-4
dc.b $83,'rp',$80!'0'
cnop 0,2
_rp0 dc.l docreate
init_rp dc.l 0
* dp Dictionairy Pointer, a variable.
; Holds place where compilation takes place. Set to stdbuffer until the
; start routine is executed, then the user dictionary is allocated and dp
; is set to the start of user dictionary.
dc.w -1
dc.l link0
link0 set *-4
dc.b $82,'d',$80!'p'
cnop 0,2
_dp dc.l docreate
dc.l stdbuffer
; the next two cells hold the start of the userdictionary and the length
; these are patched by the startup routine, after the memory block is
; allocated.
dc.l 0
dc.l $10000
* #out Number characters output since last cr.
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'#ou',$80!'t'
cnop 0,2
_number_out dc.l docreate,0
* #line Number of cr since last 'page'
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'#lin',$80!'e'
cnop 0,2
_number_line dc.l docreate,0
* base Base holds the current number radix.
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'bas',$80!'e'
cnop 0,2
_base dc.l docreate,10
* hld Hold is used in number conversions for output.
dc.w -1
dc.l link0
link0 set *-4
dc.b $83,'hl',$80!'d'
cnop 0,2
_hld dc.l docreate,0
* 'file pointer to current file info block.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,$2C,'fil',$80!'e'
cnop 0,2
_tick_file dc.l docreate,0
* 'in-file pointer to current file info block for input
dc.w -1
dc.l link0
link0 set *-4
dc.b $88,$2C,'in-fil',$80!'e'
cnop 0,2
_tick_in_file dc.l docreate,0
* type Deferred routine. Normally (type).
; Could be set to 2drop to discard output. (e.g.)
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'typ',$80!'e'
cnop 0,2
_type dc.l dodefer,_nest_type
* key Deferred routine. Normally set to (key)
; allows input from eg. diskfile, see getc in dos.
dc.w -1
dc.l link3
link3 set *-4
dc.b $83,'ke',$80!'y'
cnop 0,2
_key dc.l dodefer,_nest_key
* key? Deferred routine. Normally set to (key?)
; This ones tricky. If key is set to getc then this could return true
; until eof is reached. Routine key doesn't call key?.
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'key',$80!'?'
cnop 0,2
_key_question dc.l dodefer,_nest_key_question
* prior points to last dictionairy searched.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'prio',$80!'r'
cnop 0,2
_prior dc.l docreate,0
* state Compiling or Interpreting
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'stat',$80!'e'
cnop 0,2
_state dc.l docreate,0
* warning Flag, if on gives warning if duplicate word
dc.w -1
dc.l link3
link3 set *-4
dc.b $87,'warnin',$80!'g'
cnop 0,2
_warning dc.l docreate,-1
* dpl decimal point location for numeric input.
dc.w -1
dc.l link0
link0 set *-4
dc.b $83,'dp',$80!'l'
cnop 0,2
_dpl dc.l docreate,0
* last points to nfa of latest definition
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'las',$80!'t'
cnop 0,2
_last dc.l docreate,0
* csp Stack position for error checking.
dc.w -1
dc.l link3
link3 set *-4
dc.b $83,'cs',$80!'p'
cnop 0,2
_csp dc.l docreate,0
* current Vocabulary which receives definitions
dc.w -1
dc.l link3
link3 set *-4
dc.b $87,'curren',$80!'t'
cnop 0,2
_current dc.l docreate,_forth+4
* #vocs Number of vocabularies to search
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'#voc',$80!'s'
cnop 0,2
_number_vocs dc.l doconstant,12
* context The vocabulary search array
dc.w -1
dc.l link3
link3 set *-4
dc.b $87,'contex',$80!'t'
cnop 0,2
_context dc.l docreate,_forth+4,_forth+4,_root+4
dc.l 0,0,0,0,0,0,0,0,0,0
* 'tib Address of terminal input buffer, set when running quit
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,$2c,'ti',$80!'b'
cnop 0,2
_tick_tib dc.l docreate,tibbuffer
* width Width of the name field
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'widt',$80!'h'
cnop 0,2
_width dc.l docreate,31
* voc-link Start of the vocabulary linked-list, in temporal order,
; used in forgetting in the proper order.
dc.w -1
dc.l link2
link2 set *-4
dc.b $88,'voc-lin',$80!'k'
cnop 0,2
_voc_link dc.l docreate,Voc_link
* lib-link Start of linked list of Amiga libraries, which are
; mayby open or closed. A seperate word traverses the list when bye'ing
; and closes any opened library. (close-libs).
dc.w -1
dc.l link0
link0 set *-4
dc.b $88,'lib-lin',$80!'k'
cnop 0,2
_lib_link dc.l docreate,Lib_link
* file-link Start of linked list of all the files. Will be closed
; by exiting. (close-files)
dc.w -1
dc.l link2
link2 set *-4
dc.b $89,'file-lin',$80!'k'
cnop 0,2
_file_link dc.l docreate,File_link
* >in Offset into input stream
dc.w -1
dc.l link2
link2 set *-4
dc.b $83,'>i',$80!'n'
cnop 0,2
_to_in dc.l docreate,0
* span Number of characters expected
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'spa',$80!'n'
cnop 0,2
_span dc.l docreate,0
* #tib Number of characters to interpret, see word
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'#ti',$80!'b'
cnop 0,2
_number_tib dc.l docreate,0
* end? Flag, on if input stream is exhausted.
dc.w -1
dc.l link1
link1 set *-4
dc.b $84,'end',$80!'?'
cnop 0,2
_end_question dc.l docreate,0
* loading Variable used to indicate when a file is being loaded.
; This variable is 0 if not loading, 1 if the first level file is being
; loaded, 2 if the second etc. The number indicates the level of nesting.
dc.w -1
dc.l link0
link0 set *-4
dc.b $87,'loadin',$80!'g'
cnop 0,2
_loading dc.l docreate,0
* lb Pointer to loadbuffer, each load file uses a seperate
; loadbuffer to keep track of loading and allow nested loading. Loadbuffers
; are 256 bytes long and have the count in the first byte.
dc.w -1
dc.l link0
link0 set *-4
dc.b $82,'l',$80!'b'
cnop 0,2
_lb dc.l docreate,0
* bl Constant blank
dc.w -1
dc.l link2
link2 set *-4
dc.b $82,'b',$80!'l'
cnop 0,2
_bl dc.l doconstant,32
* bs Constant backspace
dc.w -1
dc.l link2
link2 set *-4
dc.b $82,'b',$80!'s'
cnop 0,2
_bs dc.l doconstant,8
* bell Constant bell, flashes workbench
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'bel',$80!'l'
cnop 0,2
_bell dc.l doconstant,7
* caps A flag, if true converts to uppercase
; if false exact case has to be found, the default
; for this system. All the Amiga calls have first
; characters upper case as in the RKM.
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'cap',$80!'s'
cnop 0,2
_caps dc.l docreate,0
* CAPS If caps is set on this will get it back by 0 CAPS !
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'CAP',$80!'S'
cnop 0,2
_CAPS dc.l nest,_caps,_exit
* fill (s start-addr count char -- ) fill memory with char
; limited to 64k bytes
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'fil',$80!'l'
cnop 0,2
_fill dc.l *+4
movem.l (sp)+,d0-d1/a0
bra.s 2$
1$ move.b d0,(a0)+
2$ dbra d1,1$
jmp (a3)
* erase (s addr len -- ) fill string with zeroes
dc.w -1
dc.l link1
link1 set *-4
dc.b $85,'eras',$80!'e'
cnop 0,2
_erase dc.l *+4
pea 0
bra _fill+4
* blank (s addr len -- ) fill string with blanks
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'blan',$80!'k'
cnop 0,2
_blank dc.l *+4
pea $20
bra _fill+4
* count (s addr -- addr+1 len ) returns length of the string
; and the string. Strings as in basic with preceding
; length byte.
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'coun',$80!'t'
cnop 0,2
_count dc.l *+4
moveq #0,d0
move.l (sp),a0
move.b (a0)+,d0
move.l a0,(sp)
move.l d0,-(sp)
jmp (a3)
* length (s addr -- addr+2 len ) Same as above, for size in a word
dc.w -1
dc.l link0
link0 set *-4
dc.b $86,'lengt',$80!'h'
cnop 0,2
_length dc.l *+4
move.l (sp),a0
moveq #0,d0
move.w (a0)+,d0
move.l a0,(sp)
move.l d0,-(sp)
jmp (a3)
* move (s from to len -- ) move strings without overlap
dc.w -1
dc.l link1
link1 set *-4
dc.b $84,'mov',$80!'e'
cnop 0,2
_move dc.l *+4
move.l 4(sp),d0
cmp.l 8(sp),d0
bhi _cmove_up+4
bra _cmove+4
; subroutine to convert character in d4 to upper case
to_upper cmpi.b #'a',d4 ;label - to_upper
bcs.s 1$
cmpi.b #'z',d4
bhi.s 1$
subi.b #32,d4
1$ rts
* upc (s char -- char' ) change character to upper case
dc.w -1
dc.l link1
link1 set *-4
dc.b $83,'up',$80!'c'
cnop 0,2
_upc dc.l *+4
move.w (sp),d4
bsr to_upper
move.w d4,(sp)
jmp (a3)
* upper (s addr len -- ) convert string to upper case
dc.w -1
dc.l link1
link1 set *-4
dc.b $85,'uppe',$80!'r'
cnop 0,2
_upper dc.l *+4
move.l (sp)+,d0
move.l (sp)+,a0
bra.s 2$
1$ move.b (a0),d4
bsr to_upper
move.b d4,(a0)+
2$ dbra d0,1$
jmp (a3)
* here (s -- addr ) return address of the next location
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'her',$80!'e'
cnop 0,2
_here dc.l *+4
move.l _dp+4,-(sp)
jmp (a3)
* pad (s -- addr ) temporary storage for number conversion
dc.w -1
dc.l link0
link0 set *-4
dc.b $83,'pa',$80!'d'
cnop 0,2
_pad dc.l *+4
move.l _dp+4,-(sp)
move.l #160,d0 ;$a0=160
add.l d0,(sp)
jmp (a3)
* -trailing (s addr len -- addr len' ) remove trailing blanks
; Strings in this system have a trailing zero to
; allow these strings to be used as parameters for
; rom calls.
dc.w -1
dc.l link1
link1 set *-4
dc.b $89,$2d,'trailin',$80!'g'
cnop 0,2
_minus_trailing dc.l *+4
move.l (sp)+,d0
beq.s 4$ ;if zero return now
move.l (sp),a0
tst.b -1(a0,d0.w) ;check last char
bne.s 1$
subq.l #1,d0 ;adjust for trailing zero's
1$ add.l d0,a0
moveq #32,d1
ori #%00100,ccr
bra.s 3$
2$ cmp.b -(a0),d1
3$ dbne d0,2$
addq.w #1,d0
4$ move.l d0,-(sp)
jmp (a3)
* comp (s addr1 addr2 len -- -1|0|1 ) compares strings
; returns -1 if str1<str2, 0 if str1=str2
; 1 if str1>str2.
dc.w -1
dc.l link3
link3 set *-4
dc.b $84,'com',$80!'p'
cnop 0,2
_comp dc.l *+4
movem.l (sp)+,d0/a0-a1
pea -1
ori #%00100,ccr ;set z, pretend equal
bra.s 4$
1$ cmpm.b (a0)+,(a1)+
4$ dbne d0,1$
bcs.s 3$
beq.s 2$
addq.l #1,(sp)
2$ addq.l #1,(sp)
3$ jmp (a3)
* caps-comp same as above but each character is converted to
; upper case before comparing
dc.w -1
dc.l link3
link3 set *-4
dc.b $89,'caps-com',$80!'p'
cnop 0,2
_caps_comp dc.l *+4
movem.l (sp)+,d0/a0-a1
pea -1
ori #%00100,ccr
bra.s 4$
1$ move.b (a0)+,d4
bsr to_upper
move.b d4,d1
move.b (a1)+,d4
bsr to_upper
cmp.b d1,d4
4$ dbne d0,1$
bcs.s 3$
beq.s 2$
addq.l #1,(sp)
2$ addq.l #1,(sp)
3$ jmp (a3)
* compare do a compare depending on the caps flag, returns the
; same as above.
dc.w -1
dc.l link3
link3 set *-4
dc.b $87,'compar',$80!'e'
cnop 0,2
_compare dc.l *+4
move.l _caps+4,d0 ;tst doesn't do n(PC) as mode
; this is the same
beq _comp+4
bra _caps_comp+4
